home *** CD-ROM | disk | FTP | other *** search
/ POINT Software Programming / PPROG1.ISO / pascal / swag / misc.swg / 0099_OOP Paradox Interface.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1994-02-15  |  13.6 KB  |  488 lines
  1. {$F+,O+}
  2. UNIT OOPX;
  3.                      (**************************************)
  4.                      (*         OOPX  Version 1.00         *)
  5.                      (* Object-Oriented Interface for the  *)
  6.                      (*    Paradox Engine Version 2.0      *)
  7.                      (*    and Turbo Pascal Version 6.0    *)
  8.                      (*     Copyright 1991 Brian Corll     *)
  9.                      (**************************************)
  10.                      (*    Portions Copyright 1990-1991    *)
  11.                      (*        Borland International       *)
  12.                      (**************************************)
  13.  
  14.  
  15. INTERFACE
  16.  
  17. Uses PXEngine;
  18.  
  19.  
  20.  
  21. const
  22.      PXError : Integer = PXSUCCESS;
  23.      VarLong  = 1;
  24.      VarInt   = 2;
  25.      VarDate  = 3;
  26.      VarDoub  = 4;
  27.      VarAlpha = 5;
  28.      VarShort = 6;
  29.  
  30. type
  31.    DateRec = record
  32.       M,D,Y : Integer;
  33.       end;
  34.  
  35. type
  36.    PXObject = object
  37.       ErrCode : Integer;
  38.       THandle : TableHandle;
  39.       RHandle : RecordHandle;
  40.       LHandles: Array[1..32] of LockHandle;
  41.       SearchBuf : RecordHandle;
  42.       LastLock: Byte;
  43.       Name    : String;
  44.       RecNo   : RecordNumber;
  45.       Locked  : Boolean;
  46.       UnLocked: Boolean;
  47.       constructor InitName(TblName : String);
  48.       constructor InitOpen(TblName : String;
  49.                   IndexID : Integer;
  50.                   SaveEveryChange : Boolean);
  51.       constructor InitCreate(TblName : String;
  52.                   NFields : Integer;
  53.                   Fields,Types : NamesArrayPtr);
  54.       destructor Done;
  55.       procedure  ClearErrors;
  56.       procedure  LockRecord;
  57.       procedure  LockTable(LockType : Integer);
  58.       procedure  UnLockRecord;
  59.       procedure  UnLockTable(LockType : Integer);
  60.       procedure  RenameTable(FromName,ToName : String);
  61.       procedure  AddTable(AddTableName : String);
  62.       procedure  CopyTable(CopyName : String);
  63.       procedure  CreateIndex(NFlds : Integer;
  64.                  FldHandles : FieldHandleArray;
  65.                  Mode : Integer);
  66.       procedure  Encrypt(Password : String);
  67.       procedure  Decrypt(Password : String);
  68.       procedure  DeleteIndex(IndexID : Integer);
  69.       procedure  EmptyTable;
  70.       procedure  EmptyRecord;
  71.       procedure  ReadRecord;
  72.       procedure  InsertRecord;
  73.       procedure  AddRecord;
  74.       procedure  UpdateRecord;
  75.       procedure  DeleteRecord;
  76.       procedure  NextRecord;
  77.       procedure  PrevRecord;
  78.       procedure  GotoRecord(R : RecordNumber);
  79.       procedure  Flush;
  80.       procedure  SearchField(FHandle : FieldHandle;Mode : Integer);
  81.       procedure  SearchKey(NFlds : Integer;Mode : Integer);
  82.       procedure  InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);
  83.       procedure  PutField(FldName : NameString;var Variable);
  84.       procedure  PutLongField(FldName : NameString;var L : Longint);
  85.       procedure  GetField(FldName : NameString;var Variable);
  86.       procedure  GetLongField(FldName : NameString;var L : Longint);
  87.       function   FieldNumber(FldName : NameString) : Integer;
  88.       function   FieldName(FHandle : FieldHandle) : NameString;
  89.       function   FieldType(FHandle : FieldHandle) : NameString;
  90.       function   IsBlank(FldName : NameString) : Boolean;
  91.       function   TableChanged : Boolean;
  92.       procedure  Refresh;
  93.       procedure  Top;
  94.       procedure  Bottom;
  95.       function   GetRecordNumber : Longint;
  96.       end;
  97.  
  98.  
  99. function PXOk : Boolean;
  100.  
  101. IMPLEMENTATION
  102.  
  103.    function PXOk : Boolean;
  104.    begin
  105.       PXOk := (PXError = PXSUCCESS);
  106.    end;
  107.  
  108.    constructor PXObject.InitName;
  109.    begin
  110.       Name := TblName;
  111.    end;
  112.  
  113.    constructor PXObject.InitOpen;
  114.    begin
  115.       THandle := 0;
  116.       Name := '';
  117.       ErrCode := PXTblOpen(TblName,
  118.                           THandle,
  119.                           IndexID,
  120.                           SaveEveryChange);
  121.       If ErrCode = PXSUCCESS then
  122.       begin
  123.       Name := TblName;
  124.       ErrCode := PXRecBufOpen(THandle,RHandle);
  125.       ErrCode := PXRecBufOpen(THandle,SearchBuf);
  126.       end;
  127.       LastLock := 0;
  128.       FillChar(LHandles,32,0);
  129.       PXError := ErrCode;
  130.       Locked := False;
  131.       UnLocked := False;
  132.    end;
  133.  
  134.    constructor PXObject.InitCreate(TblName : String;
  135.                   NFields : Integer;
  136.                   Fields,Types : NamesArrayPtr);
  137.    begin
  138.       ErrCode := PXTblCreate(TblName,NFields,Fields,Types);
  139.       PXError := ErrCode;
  140.    end;
  141.  
  142.    procedure  PXObject.Encrypt(Password : String);
  143.    begin
  144.       ErrCode := PXTblEncrypt(Name,Password);
  145.       If ErrCode = PXERR_TABLEOPEN then
  146.       begin
  147.          ErrCode := PXTblClose(THandle);
  148.          If ErrCode = PXSUCCESS then
  149.          ErrCode := PXTblEncrypt(Name,Password);
  150.       end;
  151.       PXError := ErrCode;
  152.    end;
  153.  
  154.    procedure PXObject.ClearErrors;
  155.    begin
  156.       ErrCode := 0;
  157.       PXError := 0;
  158.    end;
  159.  
  160.    procedure  PXObject.Decrypt(Password : String);
  161.    begin
  162.      ErrCode := PXPswAdd(Password);
  163.      If ErrCode = PXSUCCESS then
  164.      begin
  165.       ErrCode := PXTblDecrypt(Name);
  166.       If ErrCode = PXERR_TABLEOPEN then
  167.       begin
  168.          ErrCode := PXTblClose(THandle);
  169.          If ErrCode = PXSUCCESS then
  170.          ErrCode := PXTblDecrypt(Name);
  171.       end;
  172.      end;
  173.      PXError := ErrCode;
  174.    end;
  175.  
  176.    procedure PXObject.CreateIndex(NFlds : Integer;
  177.                 FldHandles : FieldHandleArray;
  178.                 Mode : Integer);
  179.    begin
  180.       ErrCode := PXKeyAdd(Name,NFlds,FldHandles,Mode);
  181.       PXError := ErrCode;
  182.    end;
  183.  
  184.    procedure PXObject.DeleteIndex;
  185.    begin
  186.       ErrCode := PXKeyDrop(Name,IndexID);
  187.       PXError := ErrCode;
  188.    end;
  189.  
  190.    procedure PXObject.Flush;
  191.    begin
  192.       ErrCode := PXSave;
  193.       PXError := ErrCode;
  194.    end;
  195.  
  196.    procedure PXObject.LockRecord;
  197.    var LockTest : Boolean;
  198.    begin
  199.       Locked := False;
  200.       Inc(LastLock);
  201.       ErrCode := PXNetRecLock(THandle,LHandles[LastLock]);
  202.       ErrCode := PXNetRecLocked(THandle,LockTest);
  203.       Locked := (ErrCode = PXSUCCESS)
  204.          and LockTest;
  205.       If not Locked then Dec(LastLock);
  206.       PXError := ErrCode;
  207.    end;
  208.  
  209.    procedure PXObject.LockTable;
  210.    begin
  211.       Locked := False;
  212.       ErrCode := PXNetTblLock(THandle,LockType);
  213.       Locked := (ErrCode = PXSUCCESS);
  214.       PXError := ErrCode;
  215.    end;
  216.  
  217.    procedure  PXObject.UnLockRecord;
  218.    begin
  219.       UnLocked := False;
  220.       ErrCode := PXNetRecUnlock(THandle,LHandles[LastLock]);
  221.       If (ErrCode = PXSUCCESS) then
  222.       begin
  223.          UnLocked := True;
  224.          LHandles[LastLock] := 0;
  225.          Dec(LastLock);
  226.       end;
  227.    end;
  228.  
  229.    procedure  PXObject.UnLockTable(LockType : Integer);
  230.    begin
  231.       UnLocked := False;
  232.       ErrCode := PXNetTblUnlock(THandle,LockType);
  233.       PXError := ErrCode;
  234.       UnLocked := (PXError = PXSUCCESS);
  235.    end;
  236.  
  237.    procedure PXObject.RenameTable(FromName,ToName : String);
  238.    begin
  239.       ErrCode := PXTblRename(FromName,ToName);
  240.       PXError := ErrCode;
  241.    end;
  242.  
  243.    procedure PXObject.AddTable(AddTableName : String);
  244.    begin
  245.       ErrCode := PXTblAdd(AddTableName,Name);
  246.       PXError := ErrCode;
  247.    end;
  248.  
  249.    procedure PXObject.CopyTable(CopyName : String);
  250.    begin
  251.       ErrCode := PXTblCopy(Name,CopyName);
  252.       PXError := ErrCode;
  253.    end;
  254.  
  255.    procedure PXObject.EmptyTable;
  256.    begin
  257.       ErrCode := PXTblEmpty(Name);
  258.       PXError := ErrCode;
  259.    end;
  260.  
  261.    procedure PXObject.EmptyRecord;
  262.    begin
  263.       ErrCode := PXRecBufEmpty(RHandle);
  264.       PXError := ErrCode;
  265.    end;
  266.  
  267.    procedure PXObject.ReadRecord;
  268.    begin
  269.       ErrCode := PXRecGet(THandle,RHandle);
  270.       PXError := ErrCode;
  271.    end;
  272.  
  273.    procedure PXObject.InsertRecord;
  274.    begin
  275.       ErrCode := PXRecInsert(THandle,RHandle);
  276.       PXError := ErrCode;
  277.    end;
  278.  
  279.    procedure PXObject.AddRecord;
  280.    begin
  281.       ErrCode := PXRecAppend(THandle,RHandle);
  282.       PXError := ErrCode;
  283.    end;
  284.  
  285.    procedure PXObject.UpdateRecord;
  286.    begin
  287.       ErrCode := PXRecUpdate(THandle,RHandle);
  288.       PXError := ErrCode;
  289.    end;
  290.  
  291.    procedure PXObject.DeleteRecord;
  292.    begin
  293.       ErrCode := PXRecDelete(THandle);
  294.       PXError := ErrCode;
  295.    end;
  296.  
  297.    procedure PXObject.NextRecord;
  298.    begin
  299.       ErrCode := PXRecNext(THandle);
  300.       PXError := ErrCode;
  301.    end;
  302.  
  303.    procedure PXObject.PrevRecord;
  304.    begin
  305.       ErrCode := PXRecPrev(THandle);
  306.       PXError:= ErrCode;
  307.    end;
  308.  
  309.    procedure PXObject.GotoRecord(R : RecordNumber);
  310.    begin
  311.       ErrCode:= PXRecGoto(THandle,R);
  312.       PXError := ErrCode;
  313.    end;
  314.  
  315.    procedure PXObject.PutField(FldName : NameString;var Variable);
  316.    var FType : NameString;
  317.        FirstChar : Char;
  318.        FHandle : FieldHandle;
  319.    begin
  320.       FHandle := FieldNumber(FldName);
  321.       If (PXError <> PXSUCCESS) then Exit;
  322.       ErrCode := PXFldType(THandle,FHandle,FType);
  323.       FirstChar := FType[1];
  324.       case FirstChar of
  325.       'D' : ErrCode := PXPutDate(RHandle,FHandle,TDate(Variable));
  326.       'A' : ErrCode := PXPutAlpha(RHandle,FHandle,String(Variable));
  327.       '$','N'
  328.           : ErrCode := PXPutDoub(RHandle,FHandle,Double(Variable));
  329.       'S' : ErrCode := PXPutShort(RHandle,FHandle,Integer(Variable));
  330.       end;
  331.       PXError := ErrCode;
  332.    end;
  333.  
  334.    procedure PXObject.InitSearchBuf(FldName : NameString;var Variable;VarType : Byte);
  335.    var FHandle : FieldHandle;
  336.    begin
  337.       FHandle := FieldNumber(FldName);
  338.       If (PXError <> PXSUCCESS) then Exit;
  339.       case VarType of
  340.       VarDate  : ErrCode := PXPutDate(SearchBuf,FHandle,TDate(Variable));
  341.       VarAlpha : ErrCode := PXPutAlpha(SearchBuf,FHandle,String(Variable));
  342.       VarDoub  : ErrCode := PXPutDoub(SearchBuf,FHandle,Double(Variable));
  343.       VarShort : ErrCode := PXPutShort(SearchBuf,FHandle,Integer(Variable));
  344.       VarLong  : ErrCode := PXPutLong(SearchBuf,FHandle,Longint(Variable));
  345.       end;
  346.       PXError := ErrCode;
  347.    end;
  348.  
  349.    procedure PXObject.PutLongField(FldName : NameString;var L : Longint);
  350.    var FHandle : FieldHandle;
  351.    begin
  352.       FHandle := FieldNumber(FldName);
  353.       If (PXError <> PXSUCCESS) then Exit;
  354.       ErrCode := PXPutLong(RHandle,FHandle,L);
  355.       PXError := ErrCode;
  356.    end;
  357.  
  358.    procedure PXObject.GetField(FldName : NameString;var Variable);
  359.    var FType : NameString;
  360.        FirstChar : Char;
  361.        FHandle : FieldHandle;
  362.    begin
  363.       FHandle := FieldNumber(FldName);
  364.       If (PXError <> PXSUCCESS) then Exit;
  365.       ErrCode := PXFldType(THandle,FHandle,FType);
  366.       FirstChar := FType[1];
  367.       case FirstChar of
  368.       'D' : ErrCode := PXGetDate(RHandle,FHandle,TDate(Variable));
  369.       'A' : ErrCode := PXGetAlpha(RHandle,FHandle,String(Variable));
  370.       '$','N'
  371.           : ErrCode := PXGetDoub(RHandle,FHandle,Double(Variable));
  372.       'S' : ErrCode := PXGetShort(RHandle,FHandle,Integer(Variable));
  373.       end;
  374.       PXError := ErrCode;
  375.    end;
  376.  
  377.    procedure  PXObject.GetLongField(FldName : NameString;var L : Longint);
  378.    var FHandle : FieldHandle;
  379.    begin
  380.       FHandle := FieldNumber(FldName);
  381.       If (PXError <> PXSUCCESS) then Exit;
  382.       ErrCode := PXGetLong(RHandle,FHandle,L);
  383.       PXError := ErrCode;
  384.    end;
  385.  
  386.    function PXObject.GetRecordNumber : Longint;
  387.    begin
  388.       ErrCode := PXRecNum(THandle,RecNo);
  389.       If (ErrCode = PXSUCCESS) then
  390.          GetRecordNumber := RecNo;
  391.       PXError := ErrCode;
  392.    end;
  393.  
  394.    function PXObject.FieldNumber(FldName : NameString) : Integer;
  395.    var FldHandle : FieldHandle;
  396.    begin
  397.       ErrCode := PXFldHandle(THandle,FldName,FldHandle);
  398.       If (ErrCode = PXSUCCESS) then FieldNumber := FldHandle
  399.       else FieldNumber := 0;
  400.       PXError := ErrCode;
  401.    end;
  402.  
  403.    function PXObject.IsBlank(FldName : NameString) : Boolean;
  404.    var Blank : Boolean;
  405.        FHandle : FieldHandle;
  406.    begin
  407.       FHandle := FieldNumber(FldName);
  408.       If (ErrCode <> PXSUCCESS) then PX(PXError);
  409.       IsBlank := False;
  410.       ErrCode := PXFldBlank(RHandle,FHandle,Blank);
  411.       If ErrCode = PXSUCCESS then IsBlank := Blank;
  412.       PXError := ErrCode;
  413.    end;
  414.  
  415.    function PXObject.TableChanged : Boolean;
  416.    var Changed : Boolean;
  417.    begin
  418.       TableChanged := False;
  419.       ErrCode := PXNetTblChanged(THandle,Changed);
  420.       If ErrCode = PXSUCCESS then
  421.          TableChanged := Changed;
  422.       PXError := ErrCode;
  423.    end;
  424.  
  425.    procedure PXObject.Refresh;
  426.    begin
  427.       ErrCode := PXNetTblRefresh(THandle);
  428.       PXError := ErrCode;
  429.    end;
  430.  
  431.    function  PXObject.FieldName(FHandle : FieldHandle) : NameString;
  432.    var FName : NameString;
  433.    begin
  434.       ErrCode := PXFldName(THandle,FHandle,FName);
  435.       If ErrCode = PXSUCCESS then
  436.          FieldName := FName
  437.       else
  438.          FIeldName := '';
  439.       PXError := ErrCode;
  440.    end;
  441.  
  442.    procedure PXObject.SearchField(FHandle : FieldHandle;Mode : Integer);
  443.    begin
  444.       ErrCode := PXSrchFld(THandle,SearchBuf,FHandle,Mode);
  445.       PXError := ErrCode;
  446.    end;
  447.  
  448.    procedure PXObject.SearchKey(NFlds : Integer;Mode : Integer);
  449.    begin
  450.       ErrCode := PXSrchKey(THandle,SearchBuf,NFlds,Mode);
  451.       PXError := ErrCode;
  452.    end;
  453.  
  454.    function  PXObject.FieldType(FHandle : FieldHandle) : NameString;
  455.    var FType : NameString;
  456.    begin
  457.       FieldType := '';
  458.       ErrCode := PXFldType(THandle,FHandle,FType);
  459.       If ErrCode = PXSUCCESS then FieldType := FType;
  460.       PXError := ErrCode;
  461.    end;
  462.  
  463.    procedure PXObject.Top;
  464.    begin
  465.       ErrCode := PXRecFirst(THandle);
  466.       PXError := ErrCode;
  467.    end;
  468.  
  469.    procedure PXObject.Bottom;
  470.    begin
  471.       ErrCode := PXRecLast(THandle);
  472.       PXError := ErrCode;
  473.    end;
  474.  
  475.  
  476.    destructor PXObject.Done;
  477.    begin
  478.       ErrCode := PXRecBufClose(RHandle);
  479.       ErrCode := PXRecBufClose(SearchBuf);
  480.       ErrCode := PXTblClose(THandle);
  481.       PXError := ErrCode;
  482.    end;
  483.  
  484. begin
  485. end.
  486.  
  487.  
  488.